home *** CD-ROM | disk | FTP | other *** search
/ Aminet 33 / Aminet 33 - October 1999.iso / Aminet / gfx / misc / AlgoLightBox.lha / AlgoLightBox.jf < prev    next >
Encoding:
Text File  |  1999-07-19  |  13.2 KB  |  618 lines
  1. \ AlgoLightBox
  2. \ Robert Dickow (dickow@uidaho.edu)
  3. \ a 'light box' application for rhythmic dancing light show
  4. \ synchronized to 'AlgoMusic'
  5.  
  6. \ JForth Professional 2.0 code:
  7.  
  8. \ Please note: This code has not been cleaned up. It
  9. \ still has remnants of junk from development work,
  10. \ prior versions, etc. Use and abuse at your own risk.
  11. \ This code is copyright © 1999 Robert Dickow
  12.  
  13. \ 'Algopics' was the code and development code name
  14. \ for AlgoLightBox
  15.  
  16. \ If you have JForth, this still may not compile
  17. \ as is, since some of the includes are my work
  18. \ and I probably won't give them away. At most you'd
  19. \ only have to rewrite/write a few words. Such as
  20. \ 0$constant I think and make words for a few
  21. \ Amiga system calls.
  22.  
  23. \ One BIG WARNING: Due to a bug in Picasso96, you
  24. \ will find that your system will crash if you run
  25. \ more than one instance of this program. The
  26. \ problem is in the patched AreaEnd routine. I've
  27. \ notified the P96 people, and they just tell me
  28. \ that that routine isn't used very often...
  29. \ meaning that they don't plan to fix it anytime
  30. \ soon. So, be warned.
  31.  
  32. \ include? DUMP.REGS jdev:debugger
  33. include? clone cl:topfile
  34. .need forbid()
  35.   include ju:exec_support
  36. .then
  37. include? ALGOMUSICPORTNAME bs:AlgoPics/AlgoMusic.j
  38. include? 0$constant ju:str_constant
  39. include? GR.INIT ju:amiga_graph
  40. include? ?closebox ju:amiga_events
  41. include? choose ju:random
  42. include? { ju:locals
  43. include? gr.area.init ju:polygon
  44.  
  45. ANEW Task-AlgoMusic
  46.  
  47. " $VER: AlgoLightBox V1.0 (7.20.99)" 0$constant VersionID$
  48.  
  49. " AlgoLightBox V1.0" 0$constant AlgoLightBoxName$
  50.  
  51. variable AlgoPicsSigNum
  52. variable AlgoPicsMsgPort
  53. variable AlgoReplyPort
  54. variable &AlgoMusicMsgPort
  55. 5 array  AlgoSignal
  56. variable Active
  57.  
  58. 4000 constant max_dimension
  59.  
  60. NewWindow MYWINDOW
  61.  
  62. \ DEBUG{
  63. : SetWindowTitles() ( Window 0$window 0$screen -- )
  64.   dup -1 = if-not if>abs then
  65.   swap dup -1 = if-not if>abs then swap
  66.   rot >abs -rot
  67.   CALLVOID  intuition_lib SetWindowTitles
  68. ;
  69. \ }DEBUG
  70.  
  71. \ variable 1/F-LAST1
  72. \ variable 1/F-next
  73. \ variable 1/f-bitmask
  74. \ variable 1/f-probit
  75. \ variable 1/f-flipflop
  76.  
  77. : GR.OPENAlgoWIN ( -- , Open window to test graphics. )
  78.     gr.init  ( just to make sure...opens library )
  79.     AlgoLightBoxName$ >abs myWindow ..! nw_title
  80.     300 myWindow ..! nw_Width
  81.     200 myWindow ..! nw_Height
  82.     MyWindow  gr.opencurw
  83.     0= abort" AlgoLightBox couldn't open window!"
  84. ;
  85.  
  86. variable changebkgnd
  87.  
  88. FALSE .IF
  89. : 1/F ( 1/f-last1 -- 1/f-next , generate next 1/f value)
  90.         1/f-last1 !
  91.         0 1/f-next !
  92.         64 1/f-bitmask !
  93.         78125 1/f-probit !
  94.         BEGIN
  95.                 1/f-last1 @ 1/f-bitmask @ / 1/f-flipflop !
  96.                 1/f-flipflop @ 1 =
  97.                 IF
  98.                         1/f-last1 @ 1/f-bitmask @ - 1/f-last1 !
  99.                 THEN
  100.                 10000 choose 1000 * 1/f-probit @ < ( yields 0-10000000)
  101.                 IF
  102.                         1 1/f-flipflop @ - 1/f-flipflop !
  103.                 THEN
  104.                 1/f-next @ 1/f-flipflop @ 1/f-bitmask @ * + 1/f-next !
  105.                 1/f-bitmask @ 2/ 1/f-bitmask !
  106.                 1/f-probit @ 2* 1/f-probit !
  107.                 1/f-bitmask @ 1 <
  108.         UNTIL
  109.         1/f-next @
  110. ;
  111. .THEN
  112.  
  113. AlgoMusicMsgPort  AlgoMusicMsgPort_copy
  114.  
  115. : Zero.Variables
  116.   AlgoPicsSigNum off
  117.   AlgoPicsMsgPort off
  118.   &AlgoMusicMsgPort off
  119.   Active off
  120.   0 AlgoSignal   5 cells erase
  121. ;
  122.  
  123. AlgoMessage AlgoCommandMsg
  124.  
  125. \ DEBUG{
  126.  
  127.  
  128. : Register ( -- )
  129.    Forbid()
  130.    AlgoMusicPortName FindPort() if
  131.      AlgoCommandMsg
  132.      COMMAND_REGISTER over ..! ammsg_Command
  133.      0 AlgoSignal @  24 shift
  134.      1 AlgoSignal @  16 shift  |
  135.      2 AlgoSignal @  8  shift  |
  136.      3 AlgoSignal @            |
  137.      over ..! ammsg_Value1
  138.      4 AlgoSignal @ over ..! ammsg_Value2
  139.      &AlgoMusicMsgPort @ swap PutMsg()
  140.      Active ON
  141.    Then
  142.   Permit()
  143. \  active @ if
  144. \    AlgoReplyPort @  WaitPort() drop
  145. \  then
  146. ;
  147.  
  148. : Unregister  ( -- )
  149.   AlgoCommandMsg
  150.   COMMAND_UNREGISTER over  ..! ammsg_Command
  151.   &AlgoMusicMsgPort @ swap PutMsg()
  152. \  AlgoReplyPort @ WaitPort() drop ( AlgoMusic doesn't send a reply )
  153.   Active OFF
  154. ;
  155.  
  156. : Quit.AlgoPics ( msg$ -- )
  157.   \ don't output to the program or shell window
  158.   GR-CURWINDOW @ if gr.area.term GR.CLOSECURW then
  159.   count type cr
  160.   Active @ if Unregister then
  161.   5 0 do i
  162.     AlgoSignal @ ?dup if FreeSignal() then  \ free signalbits
  163.   loop
  164.   AlgoPicsMsgPort @ ?dup if DeletePort() then      \ delete message port
  165.   AlgoReplyPort   @ ?dup if DeletePort() then      \ delete message port
  166. ;
  167.  
  168.  
  169. variable sigbitmask
  170.  
  171. variable Voicemask0
  172. variable Voicemask1
  173. variable Voicemask2
  174. variable Voicemask3
  175. variable Quitmask
  176.  
  177. variable last-box-X
  178. variable last-box-Y
  179. variable last-box-YSIZE
  180. variable last-box-XSIZE
  181.  
  182. variable backgndcnt
  183. variable boxrndflg
  184.  
  185. : boxrndflg@ ( -- n )
  186.   boxrndflg @
  187. ;
  188.  
  189. : My.Clear  ( -- )
  190.   2 choose if-not gr.color@ >r 1 >r else 0 >r then
  191.   256 0 wchoose dup gr.color@ = abs + gr.color!
  192.   gr.window.rect 5 +
  193.   boxrndflg@ choose if
  194.     gr.highlight
  195.   else
  196.     gr.rect
  197.   then
  198.   r> if r> gr.color! then
  199. ;
  200.  
  201. variable last-trianglex1
  202. variable last-triangley1
  203. variable last-trianglex2
  204. variable last-triangley2
  205. variable last-trianglex3
  206. variable last-triangley3
  207. variable tri-counter
  208.  
  209.  
  210. : Display.rectwin (  -- ) \ just clear window
  211.   gr.mode@
  212.   COMPLEMENT gr.mode!
  213.   gr.window.rect gr.rect
  214.   gr.mode!
  215. ;
  216.  
  217.  
  218. : Display.Triangle  { | x1 y1 x2 y2 x3 y3 WinWidth WinHeight -- }
  219.   gr.mode@
  220.   gr.color@ ( COMPLEMENT gr.mode! )
  221.   last-trianglex1 @ dup 0< if-not
  222.                       last-triangley1 @
  223.     last-trianglex2 @ last-triangley2 @
  224.     last-trianglex3 @ last-triangley3 @
  225.     gr.triangle
  226.   else
  227.     drop
  228.   then
  229.   tri-counter @ 24 mod if-not
  230.     GR-CURWINDOW @ dup ..@ wd_Width -> WinWidth ..@ wd_Height -> WinHeight
  231.     WinWidth  10 wchoose max_dimension min dup -> x1 last-trianglex1 ! WinHeight max_dimension min 10  wchoose dup -> y1 last-triangley1 !
  232.     WinWidth  20 wchoose max_dimension min dup -> x2 last-trianglex2 ! WinHeight max_dimension min 40  wchoose dup -> y2 last-triangley2 !
  233.     WinWidth  30 wchoose max_dimension min dup -> x3 last-trianglex3 ! WinHeight max_dimension min 15  wchoose dup -> y3 last-triangley3 !
  234.   else
  235.     last-trianglex1 @ -> x1
  236.     last-triangley1 @ -> y1
  237.     last-trianglex2 @ -> x2
  238.     last-triangley2 @ -> y2
  239.     last-trianglex3 @ -> x3
  240.     last-triangley3 @ -> y3
  241.   then
  242.   256 1 wchoose  gr.color!
  243.   x1 y1 x2 y2 x3 y3 gr.triangle
  244.   gr.color!
  245.   gr.mode!
  246.   1 tri-counter +!
  247. ;
  248.  
  249. Create LocalSongName 256 allot align
  250.  
  251. : Get.SongName ( -- )
  252.   Forbid()
  253.     &AlgoMusicMsgPort @
  254.     .. AMMP_SONGNAME LocalSongName 256 cmove
  255.   Permit()
  256. ;
  257.  
  258. : Display.SongName ( -- )
  259.   Get.SongName
  260.   Gr-CurWindow @ LocalSongName AlgoLightBoxName$ SetWindowTitles()
  261. ;
  262.  
  263. variable last-song
  264.  
  265. DEFER Display1
  266. DEFER Display2
  267. DEFER Display3
  268. DEFER Display4
  269.  
  270.  
  271.  
  272. \ DEBUG{
  273. : RndSort.SongRtns { | N1 N2 RTN -- }
  274.   10 0 do
  275.       4 choose -> N1
  276.       4 choose -> N2
  277.       N1
  278.       Case
  279.       0 of
  280.         What's Display1
  281.       endof
  282.       1 of
  283.         What's Display2
  284.       endof
  285.       2 of
  286.         What's Display3
  287.       endof
  288.       3 of
  289.         What's Display4
  290.       endof
  291.       ENDCASE
  292.       -> RTN  \ put rtn away
  293.       N2
  294.       CASE
  295.       0 of
  296.         What's Display1
  297.         RTN Is Display1
  298.       endof
  299.       1 of
  300.         What's Display2
  301.         RTN Is Display2
  302.       endof
  303.       2 of
  304.         What's Display3
  305.         RTN Is Display3
  306.       endof
  307.       3 of
  308.         What's Display4
  309.         RTN Is Display4
  310.       endof
  311.       ENDCASE
  312.       -> RTN
  313.       N1
  314.       CASE
  315.       0 of
  316.         RTN Is Display1
  317.       endof
  318.       1 of
  319.         RTN Is Display2
  320.       endof
  321.       2 of
  322.         RTN Is Display3
  323.       endof
  324.       3 of
  325.         RTN Is Display4
  326.       endof
  327.       ENDCASE
  328.   loop
  329. ;
  330. \ }DEBUG
  331.  
  332. : New.song.setup ( -- )
  333.     -1 last-box-x !
  334.     -1 last-trianglex1 !
  335.     2 choose 2* boxrndflg !
  336.    24 choose 2* changebkgnd !
  337.    256 choose gr.color!
  338.    gr.mode@
  339.    JAM1 gr.mode!
  340.    gr.window.rect gr.rect
  341.    gr.mode!
  342.    Display.SongName
  343.    RndSort.SongRtns
  344. ;
  345.  
  346.  
  347. variable line-toggle
  348. variable last-linex
  349. variable last-liney
  350.  
  351. : Display.Line { | width height -- }
  352.   GR-CURWINDOW @ dup >r ..@ wd_Width -> width
  353.   r> ..@ wd_Height -> height
  354.   line-toggle @ 32 mod  if-not
  355.     width  1 wchoose
  356.     height  1 wchoose
  357.     last-liney ! last-linex !
  358.   then
  359.   gr.color@
  360.   30 0 do
  361.     last-linex @ last-liney @
  362.     gr.move
  363.     255 1 wchoose gr.color!
  364.     width   1 wchoose height 1 wchoose gr.draw
  365.   loop
  366.   gr.color!
  367.   1 line-toggle +!
  368. ;
  369.  
  370. : Display.Box  { | xpos ypos rndxsize rndysize xoff yoff -- }
  371.   last-box-X @ dup 0< if-not
  372.     backgndcnt @ 1+ changebkgnd @ mod dup backgndcnt !  if-not My.clear then
  373.     last-box-y @ last-box-XSIZE @ last-box-YSIZE @
  374.     boxrndflg@ choose if
  375.       gr.rect
  376.     else
  377.       gr.highlight
  378.     then
  379.   else
  380.     drop
  381.   then
  382.   GR-CURWINDOW @ dup ..@ wd_Width  16 / dup dup -> xoff 10 * swap wchoose
  383.   dup last-box-x ! -> xpos
  384.   ..@ wd_Height 16 / dup dup -> yoff 10 * swap wchoose
  385.   dup last-box-y ! -> ypos
  386.   yoff 9 * 4 wchoose -> rndysize
  387.   xoff 9 * 4 wchoose -> rndxsize
  388.   255 1 wchoose gr.color!
  389.   xpos  dup rndxsize + dup last-box-xsize !
  390.   ypos  swap over rndysize + dup last-box-ysize !
  391.     boxrndflg@ if 2 choose else 0 then  if
  392.       gr.rect
  393.     else
  394.       2 choose if
  395.         gr.dehighlight
  396.       else
  397.         gr.highlight
  398.       then
  399.     then
  400. ;
  401.  
  402. Variable CloseBoxWasHit
  403.  
  404. : ?CloseHit ( -- n )
  405.   ?closebox dup  if
  406.     CloseBoxWasHit on
  407.   then
  408. ;
  409.  
  410.  
  411. : Process.Signals ( -- )
  412.   1 0 AlgoSignal @      shift  dup Voicemask0 !
  413.   1 1 AlgoSignal @      shift  dup Voicemask1 ! |
  414.   1 2 AlgoSignal @      shift  dup Voicemask2 ! |
  415.   1 3 AlgoSignal @      shift  dup Voicemask3 ! |
  416.   1 4 AlgoSignal @      shift  dup Quitmask   ! |
  417.   sigbitmask !
  418.   Begin
  419.     sigbitmask @ wait()
  420.     dup Voicemask2 @  and if ( ." v2 ") Display1 else ( ."    ") then
  421.     dup Voicemask3 @  and if ( ." v3 ") Display2 else ( ."    ") then
  422.     dup Voicemask0 @  and if ( ." v0 ") Display3 else ( ."    ") then
  423.     dup Voicemask1 @  and if ( ." v1 ") Display4 else ( ."    ") then
  424.     &AlgoMusicMsgPort @ ..@ AMMP_SongNr
  425.     dup last-song @
  426.     = if-not
  427. \       cr ." New Song"
  428.        ( cr) last-song !
  429.        New.song.setup
  430.        gr.clear
  431.     else
  432.       drop
  433.     then
  434.     ( cr)
  435.     Quitmask @ and ?terminal 0= not or   ?closehit or
  436.   until
  437. ;
  438.  
  439. : init.AlgoCommand ( -- )
  440.   AlgoCommandMsg
  441.   0 over ..! ln_Succ
  442.   0 over ..! ln_Pred
  443.   0 over ..! ln_Name
  444.   0 over ..! ln_Pri
  445.   AlgoReplyPort @ >ABS over ..! mn_ReplyPort
  446.   sizeof() AlgoMessage swap ..! mn_Length
  447. ;
  448.  
  449. : Init.AlgoPicsMsgPort  ( -- )
  450.   0" AlgoLightBox" 0 CREATEPORT() ?dup if
  451.     dup
  452.     AlgoPicsMsgPort !
  453.     ..@ mp_SigBit   AlgoPicsSigNum !
  454.   else
  455.     " Memory Shortage!?" Quit.AlgoPics
  456.   then
  457. ;
  458.  
  459. : Init.AlgoReplyPort ( -- )
  460.   0" AlgoLightBoxRP" 0 CreatePort() ?dup if
  461.      dup AlgoReplyPort !
  462.      PA_SIGNAL swap ..! mp_Flags
  463.   else
  464.     " Ugh! Why couldn't I create my replyport?" Quit.AlgoPics
  465.   then
  466. ;
  467.  
  468. : Alloc.AlgoSignals  ( -- -1=success | 0=failure )
  469.   5 0 do
  470.     -1 AllocSignal() dup -1 = if not leave then
  471.     i  AlgoSignal  !
  472.   loop
  473. ;
  474.  
  475.  
  476. : init.algopics ( -- )
  477.   zero.variables
  478.   Init.AlgoPicsMsgPort
  479.   Init.AlgoReplyPort
  480.   Alloc.AlgoSignals
  481.   Init.AlgoCommand
  482. ;
  483.  
  484. : Find.AlgoMusic ( -- successflg )
  485.   Forbid()
  486.     AlgoMusicPortName FindPort()
  487.     dup  &AlgoMusicMsgPort !
  488.     dup if
  489.       AlgoMusicMsgPort_copy  sizeof() AlgoMusicMsgPort cmove
  490.       TRUE
  491.     then
  492.   Permit()
  493. ;
  494.  
  495. : OpenSignOnWindow ( -- )
  496.   MyWINDOW NewWINDOW.setup
  497.   MyWindow
  498.   dup
  499.   ..@ nw_Flags WINDOWSIZING xor  over ..! nw_Flags
  500.   90  Over ..! nw_maxwidth
  501.   200  Over ..! nw_maxheight
  502.   95  Over ..! nw_Height
  503.   200  swap ..! nw_Width
  504.  
  505.   MyWINDOW GR.OPENCurW 0= if abort" AlgoLightBox couldn't open window!" then
  506.   Gr-CurWindow @ AlgoLightBoxName$ dup  SetWindowTitles()
  507.   GR.BCOLOR@
  508.   GR.COLOR@
  509.  
  510.   1 dup GR.COLOR!
  511.   GR.BCOLOR!
  512.   GR.CLEAR
  513.   0 0 200 200 gr.rect
  514.   2 GR.COLOR!
  515.   10 10 GR.MOVE
  516.   "   AlgoLightBox V1.0" GR.TEXT
  517.   10 20 GR.MOVE
  518.   "     by Bob Dickow" GR.TEXT
  519.   10 30 GR.MOVE
  520.   "  (dickow@uidaho.edu)" GR.TEXT
  521.   10 40 GR.MOVE
  522.   "     July 18, 1999" GR.TEXT
  523.   10 60 GR.MOVE
  524.   3 GR.COLOR!
  525.   " Waiting for AlgoMusic" GR.TEXT
  526.  
  527.   GR.COLOR!
  528.   GR.BCOLOR!
  529. ;
  530.  
  531.  
  532.  
  533.  
  534.  
  535.  
  536.  
  537. : do.main  ( -- )
  538.   last-song off
  539.   register
  540.  
  541.   MyWINDOW NewWINDOW.setup
  542.   1024 MyWindow ..! nw_maxwidth
  543.   768  MyWindow ..! nw_maxheight
  544.  
  545.   MyWINDOW GR.OPENALGOWIN
  546.   if
  547.     gr.area.init
  548.     New.song.setup
  549.     Gr-CurWindow @ AlgoLightBoxName$ dup  SetWindowTitles()
  550.     tri-counter off
  551.     process.signals
  552.     " Pretty cool, huh?"
  553.   else
  554.     " Window Opening Problem, Dude!"
  555.   then
  556.   Quit.AlgoPics
  557. ;
  558.  
  559. : qt ( -- ) \ temporary quit for interactive prog use
  560.   " Ok Bobby! " Quit.AlgoPics
  561. ;
  562.  
  563. : Delay() ( n -- )  CALLVOID dos_lib Delay ;
  564.  
  565. variable SignOnWindowOpen
  566.  
  567.  
  568. \ Top level routine. Clone RUN\ Save-image Run <prgname>
  569. : RUN  ( -- )
  570.   SignOnWindowOpen off
  571.   GR.INIT
  572.   AlgoMusicPortName FindPort() if-not
  573.     OpenSignOnWindow
  574.     SignOnWindowOpen On
  575.   Then
  576.   'C Display.Line is Display3
  577.   'C Display.Triangle  is Display4
  578.   'C Display.Box    is Display2
  579.   'C Display.RectWin is Display1
  580. \   36 choose 1/f-last1 !
  581.    CloseBoxWasHit off
  582.    line-toggle off
  583.    24 2 mod changebkgnd !
  584.    boxrndflg off
  585.    begin
  586.     AlgoMusicPortName FindPort() if
  587.       SignOnWindowOpen @ if
  588.         GR.CloseCurw
  589.         GR.TERM
  590.         SignOnWindowOpen off
  591.       then
  592.       init.algopics
  593.       Find.AlgoMusic if
  594.         gr.init
  595.         do.main
  596.         CloseBoxWasHit on
  597.         gr.term
  598.       else
  599.         " AlgoMusic not running" quit.algopics
  600.       then
  601.     then
  602.     SignOnWindowOPen @ if
  603.       ?CloseHit drop
  604.     then
  605.     CloseBoxWasHit @ dup if-not
  606.       SignOnWindowOpen @ if-not
  607.         60 Delay()
  608.       then
  609.     then
  610.    until
  611.    SignOnWindowOpen @
  612.    if
  613.      GR.CLOSECURW
  614.      GR.TERM
  615.    then
  616. ;
  617. \ }DEBUG
  618.